perm filename CAREY4.FAI[1,BGB] blob
sn#013946 filedate 1972-12-06 generic text, type T, neo UTF8
00100 TITLE CAREYE - CART'S EYE FOUR - NOVEMBER 1972.
00200 COMMENT/
00300
00400 1. TITLES.
00500 2. MNEMONICS & NODE MACROS.
00600 3. MAIN EXECUTION & MKVICS.
00700 4. TV BUFFER & CELL BUFFER DECLARATIONS.
00800 5. TVDSKI - TV disk file input.
00900
01000 TVDSKI TV disk file input.
01100 MKVICS Make Video Intensity Contours.
01300
01400 GETROW Get a row from the TVBUF.
01500 7. GETCELL Get a cell of the row.
01600 8. ADDCELL Add a cell to VIC data structure
01700
01800 12. GETBLK Get a four word block.
01900 MAKEV Make an edge-vertex.
01910 13. DPYVIC Display Video Intensity Contour./
02000
02100
02200 ;DIMENSIONS.
02300 ↓ROWS ←← =216
02400 ↓COLS ←← =288
02500 ↓LEVS ←← =4
02600
02700 ;ACCUMULATORS.
02800 ↓Q←3
02900 ↓N←4 ↔ ↓S←5 ↔ ↓E←6 ↔ ↓W←7;North, South, East, West.
03000 ↓I←10 ;intensity serial number.
03100 ↓M←11 ;Mid-cell.
03200 ↓R←12 ;Row of the cell.
03300 ↓C←13 ;Column of the cell.
03400 ↓T←14 ;Type of the cell.
03500 ↓B←15
00100 ; ALTERNATE PDP-10 MNEMONICS.
00200
00300 OPDEF LIP[HLR]↔OPDEF LAP[HRR]
00400 OPDEF DIP[HRLM]↔OPDEF DAP[HRRM]
00500 OPDEF CAR[HLRZ]↔OPDEF CDR[HRRZ]
00600 OPDEF DIPZ[HRLZM]↔OPDEF DAPZ[HRRZM]
00700
00800 OPDEF ZIP[HRRZS]↔OPDEF ZAP[HLLZS]
00900 OPDEF WIP[HRROS]↔OPDEF WAP[HRRZS]
01000 OPDEF NIP[HLRE]↔OPDEF NAP[HRRE]
01100 OPDEF LAC[MOVE]↔OPDEF DAC[MOVEM]
01200 OPDEF SLAC[MOVS]
01300
01400 OPDEF GO[JRST]
01500 OPDEF LACI[MOVEI]↔OPDEF SLACI[MOVSI]
01600 OPDEF LAPI[HRRI]↔OPDEF LIPI[HRLI]
01700 OPDEF LACN[MOVN]↔OPDEF DACN[MOVNM]
01800 OPDEF LACM[MOVM]↔OPDEF DACM[MOVMM]
01900
02000 ;NODE MACROS.
02100
02200 DEFINE ROW(A,E){CAR A,0(E)} ↔ DEFINE COL(A,E){CDR A,0(E)}
02300 DEFINE CW (A,E){CAR A,1(E)} ↔ DEFINE CCW(A,E){CDR A,1(E)}
02400 DEFINE CONT(A,E){CAR A,2(E)}↔ DEFINE PGN(A,E){CDR A,2(E)}
02500 DEFINE UP (A,E){CAR A,3(E)} ↔ DEFINE DOWN(A,E){CDR A,3(E)}
02600
02700 DEFINE OPGN(A,E){CAR A,0(E)} ↔ DEFINE IPGN(A,E){CDR A,0(E)}
02800 DEFINE LPGN(A,E){CAR A,1(E)} ↔ DEFINE RPGN(A,E){CDR A,1(E)}
02900 DEFINE PED (A,E){CAR A,2(E)} ↔ DEFINE BRT(A,E){CDR A,2(E)}
03000 DEFINE NPGN(A,E){CAR A,3(E)} ↔ DEFINE PPGN(A,E){CDR A,3(E)}
03100
03200 DEFINE ROW.(A,E){DIP A,0(E)} ↔ DEFINE COL.(A,E){DAP A,0(E)}
03300 DEFINE CW. (A,E){DIP A,1(E)} ↔ DEFINE CCW.(A,E){DAP A,1(E)}
03400 DEFINE CONT.(A,E){DIP A,2(E)}↔ DEFINE PGN.(A,E){DAP A,2(E)}
03500 DEFINE UP. (A,E){DIP A,3(E)} ↔ DEFINE DOWN.(A,E){DAP A,3(E)}
03600
03700 DEFINE OPGN.(A,E){DIP A,0(E)} ↔ DEFINE IPGN.(A,E){DAP A,0(E)}
03800 DEFINE LPGN.(A,E){DIP A,1(E)} ↔ DEFINE RPGN.(A,E){DAP A,1(E)}
03900 DEFINE PED. (A,E){DIP A,2(E)} ↔ DEFINE BRT.(A,E){DAP A,2(E)}
04000 DEFINE NPGN.(A,E){DIP A,3(E)} ↔ DEFINE PPGN.(A,E){DAP A,3(E)}
04100
04200 DEFINE AOSROW(E){HLLM R,(E)}
04300 DEFINE SOSROW(E){HRLM R,(E)}
04400 DEFINE AOSCOL(E){HLRM C,(E)}
04500 DEFINE SOSCOL(E){HRRM C,(E)}
00100 ;MAIN EXECUTION.
00200
00300 SA: JSR TVDSKI
00400 JSR MKVICS
00500 SETZ I,↔JSR DPYVIC↔INCHRW
00600 CAIGE I,LEVS-1↔AOJA I,.-3↔GO .-5
00700
00800 ;MAKE VIDEO INTENSITY CONTOURS.
00900 MKVICS: 0
01000 BEGIN MKVICS
01100 SLACI R,1
01200 L1: SETZ I,↔JSR DPYVIC↔CAIGE I,LEVS-1↔AOJA I,.-2
01300 JSR GETROW
01400 SLACI C,1
01500 L2: JSR GETCELL
01600 SETZ I,
01700 L3: JSR ADDCELL
01800 CAIGE I,LEVS-1
01900 AOJA I,L3
02000 CAMGE C,[XWD COLS+1,COLS]
02100 AOBJP C,L2
02200 CAMGE R,[XWD ROWS+1,ROWS]
02300 AOBJP R,L1
02400 GO @MKVICS
02500 BEND
00100 ;LEVELS OF INTENSITY CONTOURS.
00200
00300 LEVEL: -1↔20↔40↔60
00400 RING: BLOCK LEVS
00500
00600 ;HORIZONTALS OF THE CURRENT ROW - DOUBLE INDEXED.
00700
00800 HSEG: FOR @' I←0,LEVS{XWD C,HSEG'I↔}
00900 FOR @' I←0,LEVS{HSEG'I: BLOCK COLS↔}
01000 HSEGEND: 0
01100
01200 ;THE CELL.
01300 FOR @' I←0,6{LEFT'I: BLOCK LEVS↔}
01400 FOR @' I←0,6{RIGHT'I: BLOCK LEVS↔}
01500
01600 ;LEFT SIDE OF THE CELL INDEXED BY I.
01700
01800 CELL11:LEFT0(I)↔XWEST:LEFT4(I)
01900 XNORTH:LEFT1(I)↔J2:LEFT5(I)
02000 WESCEL:LEFT2(I)↔WEST:LEFT6(I)
02100 XSOUTH:LEFT3(I)
02200
02300 ;RIGHT SIDE OF THE CELL INDEXED BY I.
02400
02500 NORCEL:RIGHT0(I)↔XEAST:RIGHT4(I)
02600 NORTH:RIGHT1(I)↔J1:RIGHT5(I)
02700 MIDCEL:RIGHT2(I)↔EAST:RIGHT6(I)
02800 SOUTH:RIGHT3(I)
02900
03000 ;SPACE FOR CELL SIDE BLIT SWAPPING.
03100 SWAP0:BLOCK 6↔SWAP6:0
03200
03300 ;TELEVISION SPACE.
03400 HEADER: BLOCK 12
03500 TVBUF:BLOCK =10368
03600 -2↔ROWA:BLOCK =288
03700 -2↔ROWB:BLOCK =288↔-2
03800 ROW0:XWD C,ROWA ;CURRENT ROW INDEXED BY COLUMN.
03900 ROW1:XWD C,ROWB ;PREVIOUS ROW INDEXED BY COLUMN.
04000 FLGSIX: -1 ;SIX BIT BYTES INDICATOR.
04100 TVPTR: 0 ;TVBUF BYTE POINTER.
00100 FILNAM: 0 ;FILE NAME.
00200 EXTION: 0 ;EXTENSION.
00300 0
00400 PPPN: 0 ;PROJECT-PROGRAMMER.
00500
00600
00700 ;INPUT A TELEVISION PICTURE FROM A DISK FILE.
00800 TVDSKI: 0
00900 BEGIN TVDSK
01000 LACI 303030↔DAC TVBUF
01010 LACI 300030↔DAC TVBUF+=48
01020 LACI 303030↔DAC TVBUF+=48+=48
01100 ; GO @TVDSKI
01200
01300
01400 ;DEFAULT FILE SPECIFICATION.
01500 SKIPN 1,PPPN↔LAC 1,[SIXBIT/DATBGB/]↔DAC 1,PPPN
01600 SKIPN 1,EXTION↔LAC 1,[SIXBIT/TMP/]↔DAC 1,EXTION
01700 SKIPN 1,FILNAM↔LAC 1,[SIXBIT/X/]↔DAC 1,FILNAM
01800 ;DUMP MODE DISK INPUT.
01900 INIT 1,17↔SIXBIT/DSK/↔0↔HALT
02000 LOOKUP 1,FILNAM↔HALT
02100 IN 1,[IOWD =10378,HEADER↔0]↔JFCL
02200 RELEASE 1,
02300 OUTSTR[ASCIZ" EOF"]
02400 SETZM FILNAM↔SETZ EXTION↔SETZM EXTION+1↔SETZM PPPN
02500 GO @TVDSKI
02600 BEND
02700
02800 GETROW: 0
02900 TRNN R,-1↔GO[
03000 ;ROW ZERO INITIALIZATION.
03100 SLACI 440600↔SKIPN FLGSIX↔SLACI 440400
03200 LAPI TVBUF↔DAC TVPTR
03300 LAC 1,ROW0↔LIPI 1,-1(1)↔LAC 1↔BLT(1)=287
03400 SETZM HSEG0↔LAC[XWD HSEG0,HSEG0+1]↔BLT HSEGEND↔GO .+1]
03500 ;CURRENT TO PREVIOUS & LOAD NEW CURRENT ROW FROM TVBUF.
03600 LAC 2,ROW0↔EXCH 2,ROW1↔DAC 2,ROW0
03700 LAC 1,TVPTR↔LIPI 2,-COLS
03800 ILDB 1↔DAC(2)↔SKIPE↔BRK: JFCL↔AOBJN 2,.-4
03900 DAC 1,TVPTR
04000 GO @GETROW
04100 LIT
00100 TVIOWD: XWD -=6912,TVBUF
00200 TVCLIP: 701002 ;BCLIP=7 TCLIP=0 CAM=1.
00300 TVYXW: BYTE(9)50,34,40
00400 TVERR: 0
00500
00600 ;INPUT A TELEVISION PICTURE FROM A CAMERA.
00700 ;TVCAM(CAMERA).
00800 TVCAMI: 0
00900 BEGIN TVCAM
01000 SETZM FLGSIX
01100 TVTAKE: INIT 17,17↔SIXBIT/TV/↔0
01200 GO[OUTSTR[ASCIZ"CAN'T INIT TV."]↔INCHRW↔GO .-3]
01300
01400 SETZM TVERR↔INPUT 17,TVIOWD↔MOVE 1,TVERR
01500 TRNE 1,100060↔GO .-4
01600 RELEASE 17,
01700
01800 ; REPORT ON THE ERROR BITS AND RETAKE IF NECESSARY;
01900 TRNE 1,100000↔OUTSTR [ASCIZ/TV PARITY ERROR.
02000 /]↔ TRNE 1,40 ↔OUTSTR [ASCIZ/TV DATA MISS.
02100 /]↔ TRNE 1,20 ↔OUTSTR [ASCIZ/TV NON EX MEM.
02200 /]↔ TRNE 1,100060↔JRST TVTAKE
02300 ; TIME AND DATE.
02400 CALLI 22↔MOVEM TVTIME#
02500 CALLI 14↔MOVEM TVDATE#
02600 ; CONVERT FROM GREY CODE TO GRAY CODE.
02700 HRLZI 16,[
02800 SETCM 17,(16) ;0
02900 MOVE 15,17 ;1
03000 LSH 15,-1 ;2
03100 AND 15,13 ;3
03200 XORB 17,15 ;4
03300 LSH 15,-2 ;5
03400 AND 15,14 ;6
03500 XOR 17,15 ;7
03600 MOVEM 17,(16) ;10
03700 AOBJN 16, ;11
03800 JRST ;12
03900 BYTE (4)7,7,7,7,7,7,7,7,7
04000 BYTE (4)3,3,3,3,3,3,3,3,3
04100 ]
04200 BLT 16,14
04300 LAC 16,TVIOWD
04400 HRRI 12,.+2
04500 JRST
04600 GO @TVCAMI
04700 BEND
00100 ;GET CELL POINTERS FOR ALL CONTOUR LEVELS AT CURRENT R,C.
00200 GETCELL:0
00300 BEGIN GETCELL
00400
00500 ;SWAP SIDES OF THE CELL.
00600 LAC[XWD CELL11,SWAP0]↔BLT SWAP6
00700 LAC[XWD NORCEL,CELL11]↔BLT SOUTH
00800
00900 ;CLEAR LEFT SIDE CELL POINTERS - COLUMN ZERO ONLY.
01000 TRNE C,-1↔GO .+6
01100 CDR 1,CELL11↔SETZM(1)
01200 LIPI(1)↔LAPI(1)1↔BLT(1)7*LEVS-1
01300
01400 ;CLEAR RIGHT SIDE CELL POINTERS.
01500 CDR 1,NORCEL↔SETZM(1)
01600 LIPI(1)↔LAPI(1)1↔BLT(1)7*LEVS-1
01700
01800 ;GET NORTH,CEL10,J1,XEAST IF THEY EXIST.
01900 SETZM I↔LAC Q,C
02000 L1: SKIPN 1,HSEG0(Q)↔GO[
02100 SKIPN 1,HSEG0+1(Q)↔GO L2
02200 DAC 1,@J1↔CW 1,1↔DAC 1,@XEAST↔GO L2]
02300 DAC 1,@NORTH↔PGN 0,1↔DAC 0,@NORCEL
02400 CCW 1,1↔COL 0,1↔CAIE 0,1(C)↔GO L2
02500 DAC 1,@J1↔DAC 1,@XEAST
02600 L2: ADDI Q,COLS
02700 CAIGE I,LEVS↔AOJA I,L1
02800 GO @GETCELL
02900 BEND
00100 ;ADD A TV PIXEL TO THE VIC DATA STRUCTURE OF I-LEVEL,
00200 ADDCELL:0
00300 BEGIN ADDCELL
00400 SETZM T↔LAC LEVEL(I) ;TYPE OF CELL.
00500
00600 ;CURRENT ROW AND COLUMN.
00700 LACI 1,@ROW0
00800 CAML 0(1)↔GO L4
00900 CAML -1(1)↔TRO T,10
01000
01100 ;PREVIOUS ROW, CURRENT COLUMN.
01200 LACI 1,@ROW1
01300 CAML -1(1)↔TRO T,4
01400 CAML 0(1)↔TRO T,2
01500 CAML 1(1)↔TRO T,1
02000
02100 ;JUMP TABLE FOR CASES 0 TO 17.
02150 GO@L2(T)
02200 L2: CASE0 ↔ CASE1 ↔ CASE23 ↔ CASE23
02300 CASE4 ↔ CASE5 ↔ CASE67 ↔ CASE67
02400 CASE10 ↔ CASE11 ↔ MKPGN ↔ MKPGN
02500 CASE14 ↔ CASE15 ↔ MKPGN ↔ MKPGN
02600
02700 ;POINT OF RETURN - PUT CELL DOWN.
02800 ↑L3: DAC M,@MIDCEL↔DAC S,@HSEG(I)
02900 DAC N,@NORTH↔DAC S,@SOUTH
03000 DAC E,@EAST ↔DAC W,@WEST
03100 LAC B,@ROW0
03200 ADDM B,2(M) ;BRIGHTNESS.
03300 GO @ADDCELL
03400 BEND
04310
04320 ;CLEAR SOUTH HSEG FOR THIS AND HIGHER LEVELS OF THIS CELL.
04330 L4: SETZM @HSEG(I)
04340 CAIGE I,LEVS-1
04350 AOJA I,.-2
04360 GO @ADDCELL
00100 ;FOUR EASY CASES.........CASES 0, 6, 7, 15.
00200
00300 CASE0: LAC M,@WESCEL
00400 LAC E,@WEST↔ AOSCOL E
00500 LAC S,@XSOUTH
00600 LAC N,@NORTH↔ AOSCOL N
00700 DAC N,@J1↔SETZB N,W↔SETZM @J2↔GO L3
00800
00900 CASE67: LAC M,@WESCEL
01000 LAC E,@WEST↔ AOSCOL E
01100 LAC S,@XSOUTH
01200 LAC N,@XNORTH↔ AOSCOL N
01300 DAC N,@J1↔SETZB W,@J2↔GO L3
01400
01500 CASE15: LAC M,@NORCEL
01600 LAC S,@NORTH↔ AOSROW S
01700 LAC W,@XWEST
01800 LAC E,@XEAST↔ AOSROW E
01900 SETZB N,@J1↔SETZM @J2↔GO L3
02000
02100 ;FOUR MAKE-TWO CASES.........CASES 2,3,11,14.
02200
02300 CASE23: LAC M,@WESCEL
02400 LAC W,@XWEST↔ SOSROW W
02500 LAC 2,W↔JSR MAKEV↔DAC 1,N↔AOSCOL N
02600 LAC 2,N↔JSR MAKEV↔DAC 1,E↔AOSROW E
02700 CW S,E
02800 DAC W,@J2↔DAC N,@J1↔SETZ W,↔GO L3
02900
03000 CASE11: LAC M,@NORCEL
03100 LAC E,@XEAST↔AOSROW E
03200 LAC 2,E↔JSR MAKEV↔DAC 1,S↔SOSCOL S
03300 LAC 2,S↔JSR MAKEV↔DAC 1,W↔SOSROW W
03400 SETZB N,@J1↔DAC W,@J2↔GO L3
03500
03600 CASE14: LAC M,@NORCEL
03700 LAC N,@NORTH↔AOSCOL N
03800 LAC 2,N↔JSR MAKEV↔DAC 1,E↔AOSROW E
03900 LAC 2,E↔JSR MAKEV↔DAC 1,S↔SOSCOL S
04000 CW W,E
04100 DAC N,@J1↔SETZB N,@J2↔GO L3
04200
00100 ;MAKE A ONE-CELL POLYGON/REGION.
00200
00300 MKPGN:
00400 BEGIN MKPGN
00500 JSR GETBLK↔DAC 1,M
00600 JSR GETBLK↔DAC 1,W↔SOSROW W↔SOSCOL W↔DAC W,@J2
00700 JSR GETBLK↔DAC 1,S↔AOSROW S↔SOSCOL S
00800 JSR GETBLK↔DAC 1,E↔AOSROW E↔AOSCOL E
00900 JSR GETBLK↔DAC 1,N↔SOSROW N↔AOSCOL N↔DAC N,@J1
01000
01100 CW. N,W ↔ CW. E,N ↔ CW. S,E ↔ CW. W,S
01200 CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
01300 PGN. M,N ↔ PGN. M,S ↔ PGN. M,E ↔ PGN. M,W ↔ PED. W,M
01400 LPGN. M,M↔RPGN. M,M
01500
01600 ;PLACE M INTO THE RING OF POLYGONS OF LEVEL(I).
01700
01800 SKIPE 1,RING(I)↔GO L1
01900 DAC M,RING(I)↔NPGN. M,M↔PPGN. M,M↔GO L2
02000 L1: NPGN 2,1
02100 NPGN. 2,M↔PPGN. 1,M
02200 PPGN. M,2↔NPGN. M,1
02300
02400 ;ATTACH M TO ITS IMMEDIATE SURROUNDER Q IF ANY.
02500
02600 L2: SOJL I,L4
02700 LAC Q,@MIDCEL
02800 OPGN. Q,M ;Q IS THE OUTER OF M.
02900 IPGN 1,Q
03000 JUMPE 1,[IPGN. M,Q↔AOJA I,L3] ;FIRST SON OF Q.
03100 LPGN 2,1 ;PLACE M IN RING OF SONS OF Q.
03200 LPGN. 2,M↔RPGN. M,2
03300 RPGN. 1,M↔LPGN. M,1
03400 L4: AOJA I,L3
03500
03600 BEND
02500 CASE1: LAC M,@WESCEL↔LAC S,@XSOUTH↔LAC E,@XEAST
02600 CCW. E,S↔CW. S,E↔AOSROW E
02700 LAC N,@NORTH↔LAC W,@WEST↔LAC 1,AVAIL ;KILL N & W.
02800 DAPZ 1,(N)↔DAPZ N,(W)↔DAPZ W,AVAIL
02900 SETOM(N)1↔SETOM(N)2↔SETOM(N)3
03000 SETOM(W)1↔SETOM(W)2↔SETOM(W)3
03100 SOS BLKCNT↔SOS BLKCNT↔SETZB N,@J1
03200 SETZB W,@J2↔GO L3
03300
03400 CASE10: LAC M,@NORCEL
03500 LAC N,@NORTH
03600 CCW 2,N↔JSR MAKEV↔DAC 1,Q↔DAC Q,@J1↔SOSROW Q↔AOSCOL Q
03700 LAC 2,Q↔JSR MAKEV↔DAC 1,E↔AOSROW E
03800 LAC 2,E↔JSR MAKEV↔DAC 1,S↔SOSCOL S
03900 LAC 2,S↔JSR MAKEV↔DAC 1,W↔SOSROW W↔DAC W,@J2
04000
04100 ;FIXUP HSEG TO THE EAST OF CURRENT COLUMN.
04200 AOS C↔CAME N,@HSEG(I)↔GO .+3
04300 DAC Q,@HSEG(I)↔AOJA C,.-3
04400 LIP C,C↔SOS C↔SETZ N,↔GO L3
04500
00100 ;MERGE CASES.
00200
00300 CASE4: LAC M,@WESCEL
00400 LAC 1,@XWEST
00500 LAC 2,@XNORTH↔ DAC 2,@J2
00600 LAC N,@NORTH↔ DAC N,@J1
00700 LAC S,@XSOUTH
00800 LAC E,@WEST
00900 CCW. N,E↔CW. E,N
01000 CCW. 2,1↔CW. 1,2
01100 AOSCOL N↔AOSCOL E
01200 SETZB N,W
01300 LAC Q,@NORCEL
01400 CAME M,Q
01500 GO FUSION ;WHEN DIFFERENT MAKE SAME.
01600 GO FISION ;WHEN SAME MAKE DIFFERENT.
01700
01800 CASE5: LAC M,@WESCEL
01900 LAC 1,@XWEST
02000 LAC 2,@XNORTH
02100 LAC N,@NORTH
02200 LAC S,@XSOUTH
02300 LAC E,@XEAST↔AOSROW E
02400 LAC W,@WEST
02500 CCW. E,S↔CW. S,E
02600 CCW. 2,1↔CW. 1,2
02700 LAC 1,AVAIL↔DAPZ 1,(N)↔DAPZ N,(W)
02800 DAPZ W,AVAIL↔SOS BLKCNT↔SOS BLKCNT
02900 SETOM(N)1↔SETOM(N)2↔SETOM(N)3
03000 SETOM(W)1↔SETOM(W)2↔SETOM(W)3
03100 SETZM @J1↔DAC 2,@J2↔SETZB N,W
03200 LAC Q,@NORCEL
03300 CAME M,Q
03400 GO FUSION ;WHEN DIFFERENT MAKE SAME.
03500 GO FISION ;WHEN SAME MAKE DIFFERENT.
03600
00100 FISION:
00200 BEGIN FISION
00250
00300 OUTSTR[ASCIZ" FISION."]
00500 JSR GETBLK↔DAC 1,Q ;NEW POLGON-REGION.
00600 LAC 2,@XNORTH
00700 LAC(2)↔DAC 2,EVMIN# ;UPPER MOST LEFT.
00800 LAC 1,2
00900
01000 ;FOLLOW INNER PERIMETER.
01100 L1: PGN. Q,2
01200 CAMG 0,(2)↔GO .+3
01300 LAC 0,(2)↔DAC 2,EVMIN
01400 CCW 2,2↔CAME 2,1↔GO L1
01500
01600 LAC 0,EVMIN↔PED. 0,Q ;FIRST EDGE-VERTEX OF THE PGON.
01700
01800 LPGN. Q,Q↔RPGN. Q,Q
01900 ;PLACE Q INTO THE RING OF POLYGONS OF LEVEL(I).
02000 LAC 1,RING(I)↔NPGN 2,1
02100 NPGN. 2,Q↔PPGN. 1,Q
02200 PPGN. Q,2↔NPGN. Q,1
02300 ;ATTACH Q TO M.
02400 OPGN. M,Q ;M IS THE OUTER OF Q.
02500 IPGN 1,M
02600 JUMPE 1,[IPGN. Q,M↔GO L3] ;FIRST SON OF M.
02700 LPGN 2,1
02800 LPGN. 2,M↔RPGN. M,2
02900 RPGN. 1,M↔LPGN. M,1
03000 GO L3
03100 BEND
00100 ;POLYGON FUSION OF Q AND M - UPPERMOST LEFT PED SURVIVES.
00200 FUSION:
00300 BEGIN FUSION
00400 PED 1,Q↔PED 2,M
00500 LAC 1,(Q)↔CAMGE 1,(M)↔EXCH Q,M
00550 DAC M,@NORCEL
00600
00700 ;DELETE Q FROM THE RING AT THIS LEVEL.
00800 NPGN 1,Q↔PPGN 2,Q
00900 PPGN. 2,1↔NPGN. 1,2
01000 CAMN Q,RING(I)↔DAPZ M,RING(I)
01100
01200 ;UPDATE EDGE MENTIONS OF Q.
01300
01400 PED 1,Q↔CW 2,1
01500 PGN 0,1↔CAMN 0,M↔GO .+4
01600 PGN. M,1↔CCW 1,1↔GO .-5
01700 PGN 0,2↔CAMN 0,M↔GO .+4
01800 PGN. M,2↔CW 2,2↔GO .-5
01900
02000 ;PLACE Q'S SONS INTO M'S RING.
02100
02200 IPGN 1,Q↔JUMPE 1,L1
02300 IPGN 2,M↔ JUMPE 2,[IPGN. 1,M↔GO L1]
02400 RPGN 16,1↔ LPGN 17,2
02500 RPGN. 2,1↔ LPGN. 1,2
02600 RPGN. 16,17↔ LPGN. 17,16
02700
02800 ;RING Q OUT FROM ITS BROTHERS.
02900 L1:
03000 LPGN 1,Q↔RPGN 2,Q
03100 RPGN. 2,1↔LPGN. 1,2
03200
03300 ;DELETE Q IF IT APPEARS IN ITS FATHER.
03400
03500 OPGN 17,Q↔IPGN 2,17
03600 CAME 2,Q↔GO L2
03700 CAMN 1,Q↔SETZ 1,↔IPGN 1,17
03800
03900 ;BURN THE GARBAGE.
04000 L2:
04100 SETOM(Q)1↔SETOM(Q)2↔SETOM(Q)3
04200 LAC AVAIL↔DAPZ(Q)↔DAPZ Q,AVAIL
04300 SOS BLKCNT↔GO L3
04400 BEND
00100 ;MAKE AN EDGE/VERTEX CW OF THE ONE IN AC2, CLOBBERS ZERO.
00200 MAKEV: 0
00300 JSR GETBLK
00400 LIPI(2)↔LAPI(1)↔BLT(1)2 ;COPY
00500 CW 0,2
00600 CW. 1,2↔CCW. 2,1 ;LINK.
00700 EXCH 0,2↔CCW. 1,2↔EXCH 0,2
00800 MOVSS↔DAP 2,0↔CAME 0,1(1)↔HALT
00900 GO@MAKEV
01000
01100 ;GET A FOUR WORD BLOCK OF CORE - CLOBBERS AC0, RETURNS IN AC1.
01200 GETBLK: 0
01300 SKIPN 1,AVAIL↔GO .+12
01400 CDR(1)↔SETZM(1)
01500 SETZM 0(1)↔SETZM 1(1)↔SETZM 2(1)↔SETZM 3(1)
01600 DAP AVAIL↔AOS BLKCNT↔GO@GETBLK
01700
01800 ;GET A FOUR K BLOCK OF CORE.
01900 LAC 1,44↔LAC 0,1↔ADDI 0,10000
02000 CALLI 11↔GO[OUTSTR[ASCIZ/NO MORE CORE./]↔HALT]
02100
02200 ;CLEAR THE NEW BLOCK OF CORE.
02300 AOS 1↔DAC 2,AC2#↔LAC 2,44
02400 SETZM(1)↔LIPI(1)↔LAPI(1)1↔BLT(2)
02500
02600 ;MAKE AVAIL LIST.
02700 DAPZ 1,AVAIL↔DIP 1,1↔TLO 1,4
02800 HLRZM 1,(1)↔ADD 1,[XWD 4,4]
02900 CAIE 2,3(1)↔GO .-3↔LAC 2,AC2↔GO GETBLK+1
03000
03100 BLKCNT:0
03200 AVAIL:0
03300
00100 DPYVIC: 0
00200 BEGIN DPYVIC
00300 OPDEF UPG[703B8]
00400 X←Y←1 ↔ P←17 ↔ ED←16
00500
00600 SKIPN P,RING(I)↔GO @DPYVIC
00700 CAIL I,LEVS↔GO @DPYVIC
00800 DPB I,[POINT 4,L4,12]
00900 DAC P,P0#
01000 SETZM DPYBUF↔LAC[XWD DPYBUF,DPYBUF+1]
01100 BLT DPYBUF+=1001
01200 LACI Q,1
01300
01400 L1: PED ED,P
01500 DAC ED,E0#
01600 LACI 146 ;AIVECT.
01700
01800 L2: ROW Y,ED↔MOVNS Y↔ADDI Y,=108↔ASH Y,5↔IDIVI Y,9
01900 DPB Y,[POINT 11,0,21]
02000
02100 COL X,ED↔SUBI X,=144↔ASH X,5↔IDIVI X,9
02200 CAMGE X,[-=511]↔LAC X,[-=511]
02300 CAMLE X,[=511]↔LAC X,[=511]
02400 DPB X,[POINT 11,0,10]
02500
02600 DAC 0,DPYBUF(Q)
02700 AOS Q↔CAIN Q,=1000↔GO L3
02800 TRZN 40↔CAME ED,E0↔SKIPA↔GO .+3
02900 CCW ED,ED↔GO L2
03000 PPGN P,P
03100 CAME P,P0↔GO L1
03200
03300 L3: AOS Q↔DAPZ Q,ADDR1
03400 L4: UPG ADDR0
03500 GO @DPYVIC
03600
03700 ADDR0: DPYBUF
03800 ADDR1: 0 ;LENGTH
03900 DPYBUF: 0 ;DISPLAY BUFFER.
04000 BLOCK =1000
04100 0
04200
04300 BEND
04400 END SA